home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyInteruptSafeDebug < prev    next >
Encoding:
Text File  |  1994-09-06  |  2.9 KB  |  140 lines  |  [TEXT/PJMM]
  1. unit MyInteruptSafeDebug;
  2.  
  3. interface
  4.  
  5.     procedure InitInteruptSafeDebug;
  6.     procedure FinishInteruptSafeDebug;
  7.     procedure InteruptSafeDebug (s: str255);
  8.     procedure InteruptSafeDebugChar (ch: char);
  9.  
  10. implementation
  11.  
  12.     uses
  13.         QLowLevel;
  14.  
  15.     const
  16.         ourfont = geneva;
  17.         oursize = 9;
  18.         ourheight = 10;
  19.         ourdescent = 2;
  20.         max_pixelsize = 8;
  21.         ourrows = 12;
  22.         our_magic = $12435687;
  23.         debug = false;
  24.  
  25.     type
  26.         CharArray = packed array[char, 1..ourheight, 1..max_pixelsize] of byte;
  27.  
  28.     const
  29.         WMgrPort = $9DE;
  30.  
  31.     type
  32.         GrafPtrPtr = ^GrafPtr;
  33.  
  34.     var
  35.         baseaddr: Ptr;
  36.         rowbytes: integer;
  37.         pixelsize: integer;
  38.         ourchars: ^CharArray;
  39.         pos, count: integer;
  40.         row: integer;
  41.         magic: longint;
  42.  
  43.     procedure InitInteruptSafeDebug;
  44.         var
  45.             wp: WindowPtr;
  46.             r: rect;
  47.             i, h, c: integer;
  48.             ch: char;
  49.     begin
  50.         if debug then begin
  51.             magic := our_magic;
  52.             ourchars := POINTER(NewPtr(SizeOf(CharArray)));
  53.             SetRect(r, 0, 40, 100, 100);
  54.             wp := NewCWindow(nil, r, '', true, 0, POINTER(-1), false, 0);
  55.             SetPort(wp);
  56.             TextFont(ourfont);
  57.             TextSize(oursize);
  58.             baseaddr := CGrafPtr(wp)^.portPixMap^^.baseAddr;
  59.             pixelsize := CGrafPtr(wp)^.portPixMap^^.pixelsize;
  60.             rowbytes := BAND(CGrafPtr(wp)^.portPixMap^^.rowbytes, $3FFF);
  61.             r := screenbits.bounds;
  62.             for ch := chr(0) to chr(255) do begin
  63.                 SetRect(r, 0, 0, 100, 100);
  64.                 EraseRect(r);
  65.                 MoveTo(0, ourheight - ourdescent);
  66.                 DrawChar(ch);
  67.                 for h := 1 to ourheight do begin
  68.                     for c := 1 to pixelsize do begin
  69.                         ourchars^[ch, h, c] := BAND(AddPtrLong(baseaddr, longInt(40 + h - 1) * rowbytes + c - 1)^, $FF);
  70.                     end;
  71.                 end;
  72.             end;
  73.             DisposeWindow(wp);
  74.             SetPort(GrafPtrPtr(WMgrPort)^);
  75.             r := screenbits.bounds;
  76.             OffsetPtr(baseaddr, longInt(r.bottom - r.top - ourheight * ourrows) * rowbytes);
  77.             r.top := r.bottom - ourheight * ourrows;
  78.             EraseRect(r);
  79.             pos := 0;
  80.             row := 0;
  81.             count := (r.right - r.left) div 8 - 2;
  82.             for i := 1 to count * ourrows do begin
  83.                 InteruptSafeDebugChar(' ');
  84.             end;
  85.         end;
  86.     end;
  87.  
  88.     procedure FinishInteruptSafeDebug;
  89.     begin
  90.         if debug then begin
  91.             DisposePtr(POINTER(ourchars));
  92.         end;
  93.     end;
  94.  
  95. {$PUSH}
  96. {$D-}
  97.     procedure InteruptSafeDebugChar (ch: char);
  98.         procedure Plot (ch: char);
  99.             var
  100.                 h, c: integer;
  101.         begin
  102.             for h := 1 to ourheight do begin
  103.                 for c := 1 to pixelsize do begin
  104.                     AddPtrLong(baseaddr, longInt(h - 1 + row * ourheight) * rowbytes + pos * pixelsize + c - 1)^ := ourchars^[ch, h, c];
  105.                 end;
  106.             end;
  107.         end;
  108.     begin
  109.         if debug then begin
  110.             if magic <> our_magic then begin
  111.                 DebugStr('BANG!');
  112.             end;
  113.             Plot(ch);
  114.             pos := (pos + 1) mod count;
  115.             if pos = 0 then begin
  116.                 row := (row + 1) mod ourrows;
  117.             end;
  118.             Plot('•');
  119.         end;
  120.     end;
  121.  
  122.     procedure InteruptSafeDebug (s: str255);
  123.         var
  124.             i: integer;
  125.     begin
  126.         if debug then begin
  127.             if s = '' then begin
  128.                 InteruptSafeDebugChar('*');
  129.             end
  130.             else begin
  131.                 for i := 1 to length(s) do begin
  132.                     InteruptSafeDebugChar(s[i]);
  133.                 end;
  134.                 InteruptSafeDebugChar('.');
  135.             end;
  136.         end;
  137.     end;
  138. {$POP}
  139.  
  140. end.